InfoMagic Internet Tools 1993 July/Internet Tools.iso/RockRidge/info-service/gopher/Rice_CMS/gopher24/ph.exec

Text File | 1993-01-13 | 19.9 KB | 783 lines

/* ph exec - query name server for person.                    */
/* Nick Laflamme - U. of Notre Dame                           */
/* [e-mail]                              */
/* UDM/Nick                                                   */
/*                                                            */
/* based heavily on GOPHER EXEC by Rick Troth, Rice U.        */
/* which in turn relies heavily on Arty Ecoky's RXSOCKET      */
/* May, 1992                                                  */
/*      modified: June 4, 1992: add stack option                     */
/*                also pull in improvements from FIXAFSID            */
/*      modified: September 2, 1992: add UNIQUE, STACKALL, HOST, PORT*/
/*                options, changed calling conventions.              */
/* Last modified: December 4, 1992 - January 8, 1993: GLOBALV for    */
/*                host, port, support for FIELDS and                 */
/*                fill-in-the-blanks queries                         */

/* return codes:             */
/*  0: no problem            */
/*  1: no matches            */
/*  2: too many matches      */
/*  3: bad parameters        */
/*  4: no end of data?       */
/*  5: Read or Write failed  */
/*  6: internal error        */
/*  7: user signalled done   */
/*  8: not unique            */
/*100: incorrect use/environ */

signal prologue                         /* skip to start of code      */

/* SYNTAX: and NOVALUE: come first so REXX can always find them       */

syntax:                                 /* in case of syntax error    */
erc = rc                                /* preserve error code        */
$error='REXX error' erc 'in line' sigl':' errortext(erc)
say $error                              /* get excited                */
say "Line" sigl':' sourceline(sigl)     /* show offending line        */
trace '?r'; nop                         /* start trace mode for debug */
rc = Socket('Terminate')
exit erc

novalue:
$error='Novalue error in line' sigl
say $error                              /* get excited                */
say sourceline(sigl)                    /* show offending line        */
trace '?r'; nop                         /* start trace mode for debug */
rc = Socket('Terminate')
exit 100

prologue:                               /* start of real code         */
signal on novalue             /* complain about missing vairables     */
signal on syntax              /* semi-graceful exit for syntax errors */
parse source . invocation progfn progft progfm calledas addressee

parse arg wanthelp .          /* check first argument                 */
select
when wanthelp='?' then
 signal somehelp        /* break to explanation                 */
when wanthelp='??' then
 signal morehelp        /* break to long explanation            */
otherwise
 nop                    /* on with life                         */
end   /* of select on wanthelp      */

/* trace i */

/************* START OF CODE *************************/

Address "COMMAND"

progid = "CMS PH 1.98"           /* 2.00: GLOBALV, FIELDS, user input */

Signal on SYNTAX

'STATE RXSOCKET MODULE *'
If rc ^= 0 Then Do
Say "You must have RXSOCKET to run" progid
Exit rc
End  /*  If  ..  Do  */

'STATE TCPIP DATA *'
If rc ^= 0 Then Do
Say "You must have VM TCP/IP V2 accessed to run" progid
Exit rc
End  /*  If  ..  Do  */

'STATE PIPE MODULE *'
If rc ^= 0 Then Do
Say "You must have CMS Pipelines to run" progid
Exit rc
End  /*  If  ..  Do  */

HHOST = "ns.nd.edu"
HPORT = 105
unique = 0                   /* by default, not looking for just one */
stackall = 0                 /* by default, don't dump all to stack  */
stack = 0                    /* not going for stacked output         */
exitrc = 0                             /* optimistic default         */

/* Parse Arg whom "(" host hport "(" all */
Parse Arg whom "(" optstring "(" whoops
if whoops /= '' then
do
say "Calling conventions have changed."
exit 100
end
optstring = translate(optstring,' ','=') /* allow "=" as whitespace  */
do while optstring /= ''
parse var optstring thisopt optstring
select
when translate(thisopt) = 'HOST' then
parse var optstring hhost optstring
when translate(thisopt) = 'PORT' then
parse var optstring hport optstring
when translate(thisopt) = 'UNIQUE' then
do
stack = 1
unique = 1
end
when translate(thisopt) = 'STACK' then
stack = 1
when translate(thisopt) = 'STACKALL' then
do
stack = 1
stackall = 1
end
otherwise
say "Unknown option:" thisopt
end                                                      /* select */
end                                 /* do while optstring isn't null */

helpstuff = '"Quit" means leave PH.  "Accept" means return this entry.'
helpstuff = helpstuff '"Done" means leave PH and the calling program.'

/* now check global variables in case this is a Gopher-callee */
'GLOBALV SELECT PHCMS GET HOST PORT'
if host = '' then
host = hhost
if port /= '' then
do
hport = port
say hport c2d(hport)
end
if hport /= strip(hport) then
do
say 'Troth was right, I need a strip.'
hport = strip(hport)
end

if index(host,'.') = 0 then
do
if ^stack then
say "Hostname" host "doesn't contain a period.  Is that correct?"
exit 100
end
if datatype(hport,'W') = 0 then
do
if ^stack then
say hport "isn't a valid port number."
exit 100
end

/*
**   Initialize RXSOCKET
*/

maxdesc = Socket('Initialize', 'phCMS')
If maxdesc="-1" Then
do
if ^stack then
say "INITIALIZE" errno
exit 5
end

/* much of the following is copied from the RXSOCKET help files */
s  = Socket('Socket', 'AF_INET', 'Sock_Stream')
family  = AF_INET
port    = Htons(hport)

/*
**   Enable ASCII<->EBCDIC Translation Option
*/
rc = Socket('SetSockOpt', s, 'SOL_SOCKET', 'SO_EBCDIC', 1)
If rc = "-1" Then
Do
if ^stack then
say "RXSOCKET subfunction SetSockOpt returned error" errno
exit 5
End

Netaddr = Socket('GetHostByName', host)
name    = family || port || netaddr
Crc = Socket('Connect', s, name)

abort = 0

if whom = '' then
call get_target
else
data       = "query" whom||'0D25'x

if abort then /* from input screen */
do
rc = socket('Terminate')               /* ending early     */
exit 7
end

bytes_sent = Socket('Write', s, data)
if bytes_sent = -1 then
do
if ^stack then
say "Write failed.  Errno:" errno
rc = Socket('Terminate')
exit 5
end
bytes_read = Socket('Read', s, 'buffer')
if bytes_read = -1 then
do
if ^stack then
say "Read failed.  Errno:" errno
rc = Socket('Terminate')
exit 5
end

"PIPE (end \) var buffer ",
"| deblock linend 25 ",
"| stem rawdata.",
"| c: nfind 501:No matches to your query",
"| d: nfind 502:Too many entries to prin",
"| a: nfind 102",
"| b: nfind 200:Ok",
"| e: nfind 598:",
"| find 500:Did not understand query",
"| f: faninany",
"| count lines",
"| var badquery",
"\ a:",
"| specs word 3 1",
"| var howmany",
"\ b:",
"| count lines",
"| var OK",
"\ c:",
"| count lines",
"| var NotFound",
"\ e:",
"| f:",
"\ d:",
"| count lines",
"| var TooMany"

If NotFound then
do
if ^stack then
say "Nothing found for" whom
rc = Socket('Terminate')
exit 1
end

If TooMany then
do
if ^stack then
say "Too many matches for" whom||'; please be more selective.'
rc = Socket('Terminate')
exit 2
end

If BadQuery then
do
if ^stack then
say "Query not resolved; possibly bad parameters."
rc = Socket('Terminate')
exit 3
end

if OK < 1 then
do
/* try for repeated reads */
do while OK < 1
bytes_read = Socket('Read', s, 'buffer2')
if bytes_read = -1 then
do
call qsay("Severe Error: Second read failed with ErrNo:" errno)
OK = 1 /* not!  but done anyway */
exitrc = 5
end
else
do
"PIPE (end \) stem rawdata.",
"| a: fanin",
"| stem rawdata.",
"| find 200:Ok",
"| count lines",
"| var OK",
"\ var buffer2 ",
"| deblock linend 25 ",
"| a:"
end
end
end
/* hang up from application */
data       = "quit"||'0D25'x
bytes_sent = Socket('Write', s, data)
/*
**   Tell RXSOCKET that we are done with this IUCV path
*/
rc = Socket('Terminate')
If rc="-1" Then Call Error "TERMINATE", errno

if stackall then
do
"PIPE stem rawdata. | stack" /* give it all */
exit
end

if unique then
do
if howmany = 1 then
"PIPE stem rawdata. | stack" /* give it all */
else
exitrc = 8
exit exitrc
end

do i = 1 to howmany
ph.i. = ''                           /* set default value          */
"PIPE (name NewPH1) stem rawdata.",
"| locate /:"||i||":/",
"| specs 9-* 1",                   /*    strip off line prefixes */
"| strip trailing",
"| stem ph."||i||'.'
end
ph.0 = howmany

/* set up windowing environment */
"QUERY DISPLAY (LIFO"
parse pull . lines cols devtype addrtype dbcs color exthi pss pssets
/* wlines = (lines * .75)%1
wcols = (cols * .75)%1
Wpsline = lines%8
Wpscol = cols%8 */
wlines = lines-2 /* allow for borders */
wcols = cols - 4 /* allow for borders again */
Wpsline = 2
Wpscol = 3
Vlines = wlines - 2
Vcols = wcols - 1
VProtTop = 1                          /* protected lines at top     */
VProtBot = 1                          /* protected lines at bottom  */
"WINDOW DEFINE  PH" Wlines Wcols Wpsline Wpscol "(BOR VAR"
"VSCREEN DEFINE PH" Vlines Vcols VProtTop VProtBot "(PROT"
"WINDOW SHOW PH ON PH"
"VMFCLEAR"

/* Now we start to display entries, one at a time. */
i=1
done = 0
parse var whom aa ' return ' .
do while ^done
Ftitle = "PH Lookup Entry:" aa i "of" ph.0
Flen   = length(Ftitle) + 1
Fcol   = (vcols-flen)%2
"VSCREEN WRITE PH 1" fcol flen "(RES HI PROT FIELD" Ftitle
if stack then
select
when ph.0 = 1 then
PFMenu = 'F1: Help F3: Quit F5: Accept                    F12: Done'
when i = ph.0 then
PFMenu = 'F1: Help F3: Quit F5: Accept F7: Prior          F12: Done'
when i = 1 then
PFMenu = 'F1: Help F3: Quit F5: Accept           F8: Next F12: Done'
otherwise
PFMenu = 'F1: Help F3: Quit F5: Accept F7: Prior F8: Next F12: Done'
end /* select */
else
select
when ph.0 = 1 then
PFMenu = 'F1: Help F3: Quit                              '
when i = ph.0 then
PFMenu = 'F1: Help F3: Quit            F7: Prior         '
when i = 1 then
PFMenu = 'F1: Help F3: Quit                      F8: Next'
otherwise
PFMenu = 'F1: Help F3: Quit            F7: Prior F8: Next'
end /* select */
"VSCREEN WRITE PH -1 1" length(pfmenu)+1 "(RES FIELD" PFMenu
do j = 1 to ph.i.0
"VSCREEN WRITE PH" j+1 1 length(ph.i.j)+1 "( HI PROT FIELD" ph.i.j
end                                  /*    for each line of entry  */

if ph.i.0 = 0 then
do
if ^stack then
call qsay("Severe Error: 0 fields present for" i)
abort = 1                                /* ending early     */
done = 1
exitrc = 6
leave
end
else
"VSCREEN WAITREAD PH"              /* wait for user input        */
/* now waitread.0 is the variable count,                           */
/* waitread.1 is the attention key just used,                      */
/* waitread.2 is the cursor position.                              */
/* all variables after those are changed fields.                   */

parse var waitread.1 ktype num
select
when (ktype = "PFKEY") & (find("1 13",num) /= 0) then
call qsay(helpstuff)
when (ktype = "PFKEY") & (find("5 17",num) /= 0) then
done = 1
when (ktype = "PFKEY") & (find("3 15",num) /= 0) then
do
abort = 1                              /* ending early     */
done = 1
end
when (ktype = "PFKEY") & (find("12 24",num) /= 0) then
do
abort = 1                              /* ending early     */
done = 1
if stack then
exitrc = 7                             /* really quit      */
end
when (ktype = "PFKEY") & (find("7 19",num) /= 0) then
do
if i > 1 then
i = i-1
else
call qsay("Already at the first entry.")
end
when (ktype = "PFKEY") & (find("8 20",num) /= 0) then
do
if i < ph.0 then
i = i+1
else
call qsay("That's the last entry.")
end
when ktype = "PFKEY" then
call qsay("PFKey" num "was used.  That's fine, nothing wrong",
"with that, it just doesn't do anything special. ")
otherwise
nop                                      /* no biggie        */
end
if done & ^abort then              /* we have a winner....       */
if stack then
"PIPE STEM PH.I. | stack LIFO"

"VSCREEN CLEAR PH"

end                                    /* wander through entries     */

"WINDOW  DELETE PH"
"VSCREEN DELETE PH"

Exit exitrc

somehelp:
say 'Give a name and get local directory information.'
exit 100                      /* non-zero RC for explanation mode     */

morehelp:
say 'Give a name and get local directory information.'
say 'By default, it looks for you and returns brief information from'
say 'Notre Dame.  Options include who you are looking for, where from,'
say 'and if you want all the server knows about the person.'
say 'Use "*" as the wildcard character.'
say ''
say 'Specify HOST by name, PORT by decimal number.  STACK, STACKALL,'
say 'and UNIQUE are other CMS programs to use.'
say 'Syntax:' progfn '{whom} {( {HOST host} {PORT port}'
say             '{STACK|STACKALL|UNIQUE} }'
exit 100


Qsay:                        /* cheap SAY command for fullscreen     */
procedure
parse arg message

"QUERY DISPLAY (LIFO"
parse pull . lines cols devtype addrtype dbcs color exthi pss pssets
wlines = (lines * .75)%1
wcols = (cols * .75)%1
Wpsline = lines%8
Wpscol = cols%8
Vlines = wlines - 2
Vcols = wcols - 1
VProtTop = 1                          /* protected lines at top     */
VProtBot = 1                          /* protected lines at bottom  */
"WINDOW DEFINE  QUICKIE" Wlines Wcols Wpsline Wpscol "(BOR VAR"
"VSCREEN DEFINE QUICKIE" Vlines Vcols VProtTop VProtBot "(PROT"
"WINDOW SHOW QUICKIE ON QUICKIE"
PFMenu = 'Hit <ENTER> to Continue'
a=(vcols-length(pfmenu))%2
"VSCREEN WRITE QUICKIE -1" a length(PFMenu)+1 "(RES FIELD" PFMenu
fields = 1
Field.Row.1   = 1
Field.title.1 = "Quick Message"
Field.len.1   = length(Field.title.1) + 1
Field.col.1   = (vcols-field.len.1)%2
Field.opts.1  = "HI PROT"

parse var message nextword message
fields = fields + 1
field.title.fields = ''

do while nextword ^= ''
if length(nextword) > vcols then
do
say "Too long word:" nextword
say "No message sent."
return
end
if length(nextword) + length(field.title.fields) < vcols then
do
field.title.fields = field.title.fields nextword
parse var message nextword message
end
else
do
fields = fields+1
field.title.fields = ''
end
end
do i = 2 to fields
Field.Row.i   = i
Field.len.i   = length(Field.title.i) + 1
Field.col.i   = 1
Field.opts.i  = "HI PROT"
end

do i = 1 to fields
"VSCREEN WRITE QUICKIE"  Field.row.i Field.col.i Field.len.i,
    "(" Field.opts.i "FIELD" Field.title.i
if length(field.title.i) >= field.len.i then
say "Trouble: field" i
end
"VSCREEN WAITREAD QUICKIE"           /* wait for user input        */

"VSCREEN CLEAR QUICKIE"
"WINDOW  DELETE QUICKIE"
"VSCREEN DELETE QUICKIE"

return

get_target:

data       = 'fields'||'0D25'x
bytes_sent = Socket('Write', s, data)
if bytes_sent = -1 then
do
say "Write failed.  Errno:" errno
rc = Socket('Terminate')
exit 5
end
bytes_read = Socket('Read', s, 'buffer')
if bytes_read = -1 then
do
say "Read failed.  Errno:" errno
rc = Socket('Terminate')
exit 5
end

"PIPE (end \) var buffer ",
"| deblock linend 25 ",
"| stem rawdata.",
"| b: nfind 200:Ok",
"| e: nfind 598:",
"| find 500:Did not understand query",
"| f: faninany",
"| count lines",
"| var badquery",
"\ b:",
"| count lines",
"| var OK",
"\ e:",
"| f:"

If BadQuery then
do
say "Severe error: fields query failed."
exit 3
end

if OK < 1 then
do
/* try for repeated reads */
do while OK < 1
bytes_read = Socket('Read', s, 'buffer2')
if bytes_read = -1 then
do
say "Severe Error: Second read failed with ErrNo:" errno
ok = 1 /* not!, but done anyway */
exitrc = 5
end
else
do
"PIPE (end \) stem rawdata.",
"| a: fanin",
"| stem rawdata.",
"| find 200:Ok",
"| count lines",
"| var OK",
"\ var buffer2 ",
"| deblock linend 25 ",
"| a:"
end
end
end

/* display code goes here. */
do i = 1 to rawdata.0
parse var rawdata.i msg ':' id ':' stuff
rawdata.i = msg||':'||right(id,2,'0')||":" stuff
end
'PIPE (end \) stem rawdata. ',
'| sort 1.8',
'| a: unique 1.8 first',
'| locate /Public/',
'| locate /Indexed/',
'| buffer', /* when in doubt.... */
'| b: lookup 1.8 master',
'| specs 10-* 1',
'| split /:/',
'| pad 10',
'| join',
'| stem indices.',
'\ a:',
'| buffer', /* when in doubt.... */
'| b:',
'| hole'

stuff.1 = 'Your query must include one of the following keys and'
stuff.2 = '(probably) by default implies "name =" unless you specify'
stuff.3 = 'the keys yourself:'
stuff.1='Type the name (first, last, nickname or a combination) of the'
stuff.2='person you wish to look up.'
stuff.3=''
stuff.4="Or, for lookups involving information other than the person's"
stuff.5="name, use the following keywords:"
do i = 1 to indices.0
j = i+5
stuff.j = indices.i
end
stuff.0 = 3+indices.0

"QUERY DISPLAY (LIFO"
parse pull . lines cols devtype addrtype dbcs color exthi pss pssets
Pscreen = "PHCMSQ"
Pwindow = "PHCMSQ"
Wlines = lines - 4
Wcols = cols - 4
Wpsline = 3
Wpscol = 3
Vlines = wlines - 1
Vcols = wcols - 1
VProtTop = 1                           /* protected lines at top     */
VProtBot = 1                           /* protected lines at bottom  */

"VMFCLEAR"                   /* clear the screen if possible/easy    */
"WINDOW DEFINE"  Pwindow Wlines Wcols Wpsline Wpscol "(BOR VAR"
"VSCREEN DEFINE" Pscreen Vlines Vcols VProtTop VProtBot "(PROT"
"WINDOW SHOW" Pwindow "ON" Pscreen
PFMenu = 'PF Keys: 3: Quit  5: Go 12: Quit'
"VSCREEN WRITE" Pscreen  "-1 1" length(PFMenu)+1 "(RES FIELD" PFMenu

fields = 3 + stuff.0         /* count of currently known fields      */
done = 0
abort = 0
qpt1 = ''
qpt2 = ''

do i = 1 to fields
Field.opts.i = 'PROTECT'
Field.change.i = 1         /* write all lines to ensure state.     */
end
/* now define fields to be used later.                               */
Field.Row.1   = 1
Field.title.1 = "PH Input Screen"
Field.len.1   = length(Field.title.1) + 1
Field.col.1   = (cols-Field.len.1)%2
Field.opts.1 = "RES NOHIGH PROTECT"

Field.row.2   = 3
Field.col.2   = 3
Field.title.2 = left(qpt1,65,' ')
Field.len.2   = length(Field.title.2) + 1
Field.opts.2 = "NOHIGH NOPROTECT"

Field.row.3   = 4
Field.col.3   = 3
Field.len.3   = 66
Field.title.3 = copies(' ',65)
Field.opts.3 = "NOHIGH NOPROTECT"

lastrow = 5  /* don't write message lines in row 5 or above. */

do i = 1 to stuff.0
lastrow = lastrow + 1
j = i+3
Field.row.j = lastrow
Field.col.j = 3
Field.Title.j = stuff.i
Field.len.j = length(stuff.i) + 1
Field.opts.j = "PROTECT HIGH"
end

/* Set the initial cursor position */
CurPosRow = Field.row.2                /* start on first query field */
CurPosCol = Field.col.2 + 1

do while done /= 1
do i = 1 to fields
if Field.change.i then
do
if Field.title.i = '' then
"VSCREEN WRITE" Pscreen  Field.row.i Field.col.i Field.len.i,
"(" Field.opts.i
else
"VSCREEN WRITE" Pscreen  Field.row.i Field.col.i Field.len.i,
"(" Field.opts.i "FIELD" Field.title.i
Field.change.i = 0              /* Reset flag                 */
if length(field.title.i) >= field.len.i then
say "Trouble: field" i
end
end

"VSCREEN CURSOR" Pscreen CurPosRow  CurPosCol
"VSCREEN WAITREAD" Pscreen           /* wait for user input        */
/* now waitread.0 is the variable count,                           */
/* waitread.1 is the attention key just used,                      */
/* waitread.2 is the cursor position.                              */
/* all variables after those are changed fields.                   */
parse var waitread.1 ktype num
if ktype = "PFKEY" & find("3 12 15 24",num) /= 0 then
do
abort = 1                                  /* ending early     */
done = 1
leave  /* don't process changes      */
end
if ktype = "CLEAR" then
do
abort = 1                                  /* ending early     */
done = 1
leave  /* don't process changes      */
end
if ktype = "PFKEY" & find("5 17",num) /= 0 then
done = 1
if ktype = "ENTER" then
done = 1

parse var waitread.2 . CurPosRow CurPosCol .

DO varcount= 3 to waitread.0                   /* changed fields   */
PARSE VAR waitread.varcount KWord ChngRow ChngCol NewVal
SELECT
WHEN ChngRow= 3 THEN                            /* query pt 1  */
DO
qpt1 = NewVal
field.change.2 = 1
field.title.2 = qpt1
End
WHEN ChngRow= 4 THEN                           /* query part 2 */
DO
qpt2 = NewVal
field.change.3 = 1
field.title.3 = qpt2
End
OTHERWISE
say "Error: unrecognized changed field."
say waitread.varcount
END  /* select on changed fields   */
END  /* parse changed fields       */
end  /* do while not done loop               */
"VSCREEN CLEAR"  Pscreen
"WINDOW  DELETE" Pwindow
"VSCREEN DELETE" Pscreen

whom = strip(qpt1) strip(qpt2)
data = 'query' whom||'0D25'x

return